;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see <http://www.gnu.org/licenses/>.


;; Copyright 2008 Francisco Ferreira


;starts the main server
(define (server port)
  (let ((accept-port (open-tcp-server port)))
    (set! skt accept-port)
    (display "Server Started\n")
    (let loop ()
      (let ((connection (read accept-port)))
	(if (not (eof-object? connection))
	    (begin
	      (handle connection)
	      (loop)))))))

;; Awful hack to allow to close a running server
(define skt 0)
(define (close-server-socket)
  (close-port skt))

;; This function handles each connection
;; In the future this will have to call a dispatch function
;; instead fo the hello-world function

(define (handle connection)
  (display (build-http-response 
	    "text/html" 
	    (hello-world
	     (parse-scgi-request connection))) 
	   connection)
  (force-output connection)
  (close-port connection))

;; Produces a request from the connection
;; a request is a table of the key,value entries in the scgi request
(define (parse-scgi-request connection)
  (get-header-table (get-netstring connection)))

;;Dumps all the keys and values in a connection
(define (dump-scgi-request request)
  (let
      ((req ""))
    (table-for-each
     (lambda (key value)
       (set! req
	     (string-append req 
			    "key:   "
			    key
			    "\n"
			    "value: "
			    value
			    "\n"
			    "-----------------------------------------------\n")))
       request)
     req))

;; Prepares a string containing the http response
(define (build-http-response type content)
  (string-append
   "Status: 200 OK\n"
   "Set-Cookie: sample=sample cookie\n"
   "Content-Type: " type "\n\n" content))


;; Parses a netstring and returns the string
;; Reference at http://en.wikipedia.org/wiki/Netstrings
(define (get-netstring connection)
  (let*
      ((size
	(string->number (read-line connection #\:)))
       (str (make-string size #\-)))
    (read-substring str 0 size  connection)
    str))

;; Gets a table that contains all the fields of the request
(define (get-header-table netstr)
  (letrec
      ((strlist (split netstr #\nul)))
    (list->table (make-pair-list strlist))))

;; Takes a list, and makes a list of pairs
;; taking two parameters from the original list for each pair
;; ToDo: This function has to be rewritten in a simpler way!!!
(define (make-pair-list li)
  (letrec
      ((result '())
       (builder (lambda (l)
		  (cond
		   ((eqv? l '())
			  result)
		   (else
		    (set! result (append result (list (cons (car l) (cadr l)))))
		    (builder (cddr l)))))))
    (builder li)))


(define (split str c)
  (call-with-input-string str (lambda (p)
				(read-all p
					  (lambda (p)
					    (read-line p c))))))

;; Hello world Page
;; ToDo: Should be replaced by a dispatch function
(define (hello-world request)
  (string-append
   "<H1> Hello World!! </H1>"
   "<HR><PRE>"
   (dump-scgi-request request)
   "</PRE><HR>"))

;; Runs the server instance
(server 8081)
